perm filename CYCOMA[1,LMM] blob
sn#034822 filedate 1973-04-13 generic text, type T, neo UTF8
(DECIMAL)
(COMMENT GENLISP - SHOULD BE IN FORLSP BUT, ---)
(DE MAX (A B) (IF (GREATERP A B) THEN A ELSE B))))))))))
(DE FIX+ (X)
(FIX (PLUS X 0.99)))
)))))))))))))))))
(DE MAXLIST (L) (FOR NEW X IN L MAX X)))))))
)))))))))))))))))
(DE TWICE (X)
(PLUS X X))
)))))))))))))))))
(DE CARLIST (L)
(FOR NEW X IN L LIST (CAR X)))
)))))))))))))))))
(DE CDRLIST (L)
(FOR NEW X IN L LIST (CDR X)))
)))))))))))))))))
(DE LCARLIST (L)
(FOR NEW X IN L LIST (CARLIST X)))
)))))))))))))))))
(DE LCDRLIST (L)
(FOR NEW X IN L LIST (CDRLIST X))))
)))))))))))))))))
(DE COPY (X)
(COND ((ATOM X)
X)
(T (CONS (COPY (CAR X))
(COPY (CDR X))))))
)))))))))))))))))
(DE NTH (L J)
(IF (EQUAL J 1)
THEN L ELSEIF (GREATERP J (LENGTH L))
THEN
(PRINT (LIST (QUOTE ARGUMENT)
J
(QUOTE (TO HIGH FOR NTH OF))
L))
NIL ELSE (FOR NEW I := (2 J)
PROG2
(SETQ L (CDR L)))))
)))))))))))))))))
(DE DIFF (L1 L2)
(FOR NEW X IN L1 WHEN (NOT (MEMBER X L2))
XLIST X))
)))))))))))))))))
(DE PLUSLIST (L) (FOR NEW X IN L PLUS X)))))))
(DE MIN (A B) (IF (GREATERP A B) THEN B ELSE A))))))))))))))
(DE LMASSOC (X Y VAL)
(PROG2
(FOR NEW PR IN Y DO
(IF (EQUAL (CAR PR) X)
THEN (RETURN (SETQ VAL (CDR PR)))))
VAL))))))))))))
(COMMENT PARTITIONERS AND CL FUNCTIONS )
(DE NUMPARTITIONS (N NUMPARTS MINPART MAXPART)
(IF (EQUAL NUMPARTS 1)
THEN
(IF (OR (GREATERP MINPART N)
(LESSP MAXPART N))
THEN NIL ELSE (LIST (LIST N)))
ELSE
(FOR NEW I := ((MAX MINPART (DIFFERENCE N
(TIMES (SUB1 NUMPARTS)
MAXPART)))
(MIN MAXPART (QUOTIENT N NUMPARTS)))
FOR NEW RESTPART IN (NUMPARTITIONS (DIFFERENCE N I)
(SUB1 NUMPARTS)
I MAXPART)
LIST
(CONS I RESTPART)))))))))
(DE CLPARTITIONS (CL PARTSIZES)
(IF (NULL PARTSIZES)
THEN
(LIST NIL)
ELSEIF
(NULL (CDR PARTSIZES))
THEN
(LIST (LIST CL))
ELSEIF
(ZEROP (CAR PARTSIZES))
THEN
(MAPCAR (FUNCTION (LAMBDA (X)
(CONS NIL X)))
(CLPARTITIONS CL (CDR PARTSIZES)))
ELSEIF
(EQUAL (CAR PARTSIZES)
(CADR PARTSIZES))
THEN
(PROG (N THISPART)
(SETQ N 1)
(SETQ THISPART (CAR PARTSIZES))
(FOR PARTSIZES ON (CDR PARTSIZES)
WHILE
(EQUAL (CAR PARTSIZES)
THISPART)
DO
(SETQ N (ADD1 N)))
(IF (NULL PARTSIZES)
THEN
(RETURN (CL=PARTS CL N THISPART)))
(RETURN (FOR NEW BIGPART IN (CLPARTS CL (TIMES N
THISPART))
AS NEW RESTPARTSLIST IS
(CLPARTITIONS (CLDIFF CL BIGPART)
PARTSIZES)
FOR NEW LITTLEPARTS IN
(CL=PARTS BIGPART N THISPART)
FOR NEW RESTPARTS IN RESTPARTSLIST XLIST
(APPEND LITTLEPARTS RESTPARTS))))
ELSE
(FOR NEW PART IN (CLPARTS CL (CAR PARTSIZES))
FOR NEW PARTS IN (CLPARTITIONS (CLDIFF CL PART)
(CDR PARTSIZES))
XLIST
(CONS PART PARTS))))))))
)))))))))))))))))
(DE
CLPARTS
(CL PARTSIZE)
(IF (ZEROP PARTSIZE)
THEN
(LIST NIL)
ELSEIF
(NULL (CDR CL))
THEN
(LIST (LIST (CONS (CAAR CL)
PARTSIZE)))
ELSE
(PROG (SIZE)
(SETQ SIZE (DIFFERENCE PARTSIZE (CLCOUNT (CDR CL))))
(RETURN (FOR NEW X := ((MAX SIZE 1)
(MIN PARTSIZE (CDAR CL)))
FOR NEW PART IN (CLPARTS (CDR CL)
(DIFFERENCE
PARTSIZE X))
XLIST FIRST
(IF (LESSP 0 SIZE)
THEN NIL ELSE (CLPARTS (CDR CL)
PARTSIZE))
(CONS (CONS (CAAR CL)
X)
PART))))))
)))))))))))))))))
(DE
CL=PARTS
(CL NPARTS PARTSIZE)
(IF
(NULL (CDR CL))
THEN
(SETQ CL (LIST (CONS (CAAR CL)
PARTSIZE)))
(LIST (FOR NEW I := (1 NPARTS)
XLIST CL))
ELSE
(FOR NEW X IN (NUMPARTITIONS (CDAR CL)
NPARTS 0 PARTSIZE)
FOR NEW Y IN (CLPARTITIONS (CDR CL)
(FOR NEW XX IN X LIST
(DIFFERENCE PARTSIZE XX)))
XLIST
(FOR NEW XX IN X AS NEW YY IN Y LIST
(IF (ZEROP XX)
THEN YY ELSE (CONS (CONS (CAAR CL)
XX)
YY))))))
)))))))))))))))))
(DE CLDIFF (CL1 CL2)
(IF (NULL CL2)
THEN CL1 ELSEIF (EQUAL (CAR CL1)
(CAR CL2))
THEN
(CLDIFF (CDR CL1)
(CDR CL2))
ELSEIF
(EQ (CAAR CL1)
(CAAR CL2))
THEN
(CONS (CONS (CAAR CL1)
(DIFFERENCE (CDAR CL1)
(CDAR CL2)))
(CLDIFF (CDR CL1)
(CDR CL2)))
ELSE
(CONS (CAR CL1)
(CLDIFF (CDR CL1)
CL2))))
)))))))))))))))))
(DE CLCOUNT (CL)
(FOR NEW X IN CL PLUS (CDR X)))
)))))))))))))))))
(DE CLPARTITIONSN (CL N MINPARTSIZE MAXPARTSIZE)
(FOR NEW PARTSIZES IN (NUMPARTITIONS (CLCOUNT CL)
N MINPARTSIZE MAXPARTSIZE)
NCONC FIRST NIL (CLPARTITIONS CL PARTSIZES)))
)))))))))))))))))
(DE CLCREATE (L)
(PROG (CL)
(FOR NEW X IN L DO (SETQ CL (CLINSERT X CL)))
(RETURN CL)))
)))))))))))))))))
(DE CLINSERT (ITEM CL)
(IF (NOT CL) THEN (LIST (CONS ITEM 1))
ELSEIF (EQUAL ITEM (CAAR CL))
THEN (REPLACE (CDR (CAR CL)) (ADD1 (CDR (CAR CL))))
CL
ELSEIF (LEQ ITEM (CAAR CL))
THEN (CONS (CONS ITEM 1) CL)
ELSE (REPLACE (CDR CL) (CLINSERT ITEM (CDR CL)))))
)))))))))))))))))
(DE CLEXPAND (CL)
(FOR NEW PR IN CL FOR NEW I := (1 (CDR PR))
LIST (CAR PR)))
)))))))))))))))))
(DE GENRAD (CL)
(IF (AND (NULL (CDR CL))
(EQUAL (CDAR CL) 1))
THEN (PERMRADS (CAAR CL) NIL T)
ELSE (FOR NEW OLDCL ON CL
AS NEW CENTER IS (CAAR OLDCL)
AS NEW NEWCL IS (CLDIFF CL (LIST (CONS CENTER 1)))
FOR NEW DEGREE := (1 (MIN (CLCOUNT NEWCL) (SUB1 (VALENCE CENTER))))
FOR NEW RADS IN (GENRADS NEWCL DEGREE)
NCONC FIRST NIL (PERMRADS CENTER RADS T))))
)))))))))))))))))
(DE GENRADS (CL N)
(IF (NULL CL)
THEN
(LIST NIL)
ELSE
(FOR NEW PARTITION IN (CLPARTITIONSN CL N 1 (CLCOUNT CL))
NCONC FIRST NIL (GENRADLIST PARTITION))))
)))))))))))))))))
(DE GENRADLIST (CLLIST)
(GROUPRADS (GENRADLIST1 (CLCREATE CLLIST))))
)))))))))))))))))
(DE GENRADLIST1 (CLCL)
(FOR NEW CLNUMPAIR IN CLCL LIST (CONS (GENRAD (CAR CLNUMPAIR))
(CDR CLNUMPAIR))))
)))))))))))))))))
(DE GROUPRADS (RADCLIST)
(IF (NULL RADCLIST)
THEN
(LIST NIL)
ELSE
(GROUPRADS1 (CAAR RADCLIST)
(CDAR RADCLIST)
(GROUPRADS (CDR RADCLIST)))))
)))))))))))))))))
(DE GROUPRADS1 (RADLIST N RADSLIST)
(IF (ZEROP N)
THEN RADSLIST
ELSE (FOR RADLIST ON RADLIST FOR NEW RADS IN
(GROUPRADS1 RADLIST (SUB1 N)
RADSLIST)
LIST
(CONS (CAR RADLIST)
RADS))))
)))))))))))))))))
(DE VALENCE (AT)
(COND ((NUMBERP AT)
AT)
((ATOM AT)
(GET AT (QUOTE VALENCE)))
(T (FREEVALENCESIZE AT))))
)))))))))))))))))
(DE GENMOL (CL)
(PROG (MINDEG RESULT NATOMS)
(IF (EQUAL 1 (SETQ NATOMS (CLCOUNT CL)))
THEN
(RETURN (PERMRADS (CAAR CL)
NIL NIL))
ELSEIF
(ZEROP (REMAINDER NATOMS 2))
THEN
(FOR NEW PART IN (CL=PARTS CL 2 (QUOTIENT NATOMS 2))
FOR NEW RADS IN (GENRADLIST PART)
DO
(SETQ RESULT (APPEND (PERMRADS NIL RADS NIL)
RESULT)))
(SETQ MINDEG 3)
ELSE
(SETQ MINDEG 2))
(SETQ NATOMS (SUB1 NATOMS))
(FOR NEW PAIR IN CL AS NEW CENTER IS (CAR PAIR)
AS NEW NEWCL IS (CLDIFF CL (LIST (CONS CENTER 1)))
FOR NEW DEG := (MINDEG (MIN (VALENCE CENTER)
NATOMS))
FOR NEW P IN (CLPARTITIONSN NEWCL DEG 1 (QUOTIENT
NATOMS 2))
FOR NEW RADS IN (GENRADLIST P)
DO
(SETQ RESULT (NCONC (PERMRADS CENTER RADS NIL)
RESULT)))
(RETURN RESULT)))
)))))))))))))))))
(DE
NUMPARTITIONS*
(U MN MAXIMA OCCURLIST)
(IF
(NULL (CDR OCCURLIST))
THEN
(NUMPARTITIONS U (CAR OCCURLIST)
MN
(CAR MAXIMA))
ELSE
(FOR
NEW FIRST :=
((FIX+ (MAX MN (DIFFERENCE
U
(FOR NEW X IN (CDR MAXIMA)
AS NEW Y IN (CDR OCCURLIST)
PLUS FIRST (TIMES (SUB1 (CAR OCCURLIST))
(CAR MAXIMA))
(TIMES X Y)))))
(MIN (CAR MAXIMA)
(QUOTIENT (DIFFERENCE U (PLUSLIST (CDR OCCURLIST)))
(CAR OCCURLIST))))
FOR NEW REST IN (IF (EQUAL (CAR OCCURLIST)
1)
THEN
(NUMPARTITIONS* (DIFFERENCE U FIRST)
1
(CDR MAXIMA)
(CDR OCCURLIST))
ELSE
(NUMPARTITIONS* (DIFFERENCE U FIRST)
FIRST MAXIMA
(CONS (SUB1 (CAR OCCURLIST))
(CDR OCCURLIST))))
XLIST
(CONS FIRST REST))))
)))))))))))))))))
(DE GROUPBY (FN L)
(IF (NULL L) THEN NIL
ELSE (PROG (FNX GROUPCDR X)
(SETQ GROUPCDR (GROUPBY FN (CDR L)))
(IF (NULL (SETQ X (LMASSOC (SETQ FNX (FN (CAR L)))
GROUPCDR NIL)))
THEN (RETURN (CONS (LIST FNX (CAR L)) GROUPCDR))
ELSE (NCONC X (LIST (CAR L)))
(RETURN GROUPCDR)))))
)))))))))))))))))
(DE FVPARTITION1 (N VL S)
(COND
((NULL VL)
(LIST NIL))
(T (PROG (SUMREST)
(SETQ SUMREST (FOR NEW X IN (CDR VL)
AS NEW SP := ((ADD1 S)
9999999)
PLUS
(TIMES SP X)))
(RETURN (FOR NEW I := ((MAX 0 (DIFFERENCE N SUMREST))
(MIN N (TIMES (CAR VL)
S)))
AS NEW PARTREST IS (FVPARTITION1
(DIFFERENCE N I)
(CDR VL)
(ADD1 S))
FOR NEW FIRSTPART IN (FVPART1
I
(CAR VL)
S)
FOR NEW RESTPART IN PARTREST XLIST
(CONS FIRSTPART RESTPART)))))))
)))))))))))))))))
(DE FVPART1 (N MAXSUM MAXOCCUR)
(COND ((ZEROP MAXOCCUR)
(LIST NIL))
(T (FOR NEW I := ((MAX 0 (DIFFERENCE N (TIMES MAXSUM
(SUB1
MAXOCCUR))))
(MIN MAXSUM (QUOTIENT N MAXOCCUR)))
FOR NEW REST IN (FVPART1 (DIFFERENCE N
(TIMES I
MAXOCCUR))
(DIFFERENCE MAXSUM I)
(SUB1 MAXOCCUR))
XLIST
(CONS I REST))))))))))
)))))))))))))))))
(DE MINLOOPS (VALENCELIST)
(MAX 0 (PROG (MXV TD)
(SETQ TD(SETQ MXV 0))
(FOR NEW X IN (CDR VALENCELIST)
AS NEW VALENCE := (3 999999)
WHEN
(NOT (ZEROP X))
DO
(IF (GREATERP VALENCE MXV)
THEN
(SETQ MXV VALENCE))
(SETQ TD (PLUS (TIMES X VALENCE)
TD)))
(RETURN (QUOTIENT (DIFFERENCE MXV TD)
2)))))))))))))))
)))))))))))))))))
(DE MAXLOOPS (VALENCELIST)
(MIN (CAR VALENCELIST)
(FIX+ (FOR NEW W IN (CDDR VALENCELIST)
AS NEW J := (2 99999)
PLUS
(TIMES 0.5 W J)))))))))
)))))))))))))))))